Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue33/undo/TextWin.pas

Pascal/Delphi Source File | 1998-02-20 | 11.7 KB | 454 lines

unit TextWin;

{ This unit contains code for an undoable memo-based text window.

  Author : Warren Kovach ([e-mail])
  Published in The Delphi Magazine }

interface

uses WinTypes, WinProcs, Messages,Classes, Graphics, Forms, Controls, StdCtrls,
     SysUtils, Dialogs, Undo, Menus;

{$IFDEF WIN32}
  {$IFDEF VER90}
const
  {$ELSE}
resourcestring
  {$ENDIF}
{$ELSE}
const
{$ENDIF}
  sTextUndoDescr = 'Undo typing "%s"';
  sTextShortUndoDescr = 'Undo "%s"';
  sTextRedoDescr = 'Redo typing "%s"';
  sTextShortRedoDescr = 'Redo "%s"';
  sTextUndoMenu = '&Undo typing';
  sTextRedoMenu = '&Redo typing';
  sClearUndoDescr = 'Undo deleting "%s"';
  sClearShortUndoDescr = 'Undo delete';
  sClearRedoDescr = 'Redo deleting "%s"';
  sClearShortRedoDescr = 'Redo delete';
  sClearUndoMenu = '&Undo deleting';
  sClearRedoMenu = '&Redo deleting';
  sFontUndoDescr = 'Undo change font';
  sFontShortUndoDescr = 'Undo font';
  sFontRedoDescr = 'Redo change font';
  sFontShortRedoDescr = 'Redo font';
  sFontUndoMenu = '&Undo font';
  sFontRedoMenu = '&Redo font';

type
  string2 = string[2];

  TClearingUndoItem = class(TUndoItem)
    private
      StartPos   : integer;
      DeletedText  : string;
      Editor : TMemo;
      function GetDescr(Msg,AText : string;TextLength : integer):string;
    protected
      function GetUndoDescription : string; override;
      function GetShortUndoDescription : string; override;
      function GetRedoDescription : string; override;
      function GetShortRedoDescription : string; override;
      function GetUndoMenuText : string; override;
      function GetRedoMenuText : string; override;
    public
      constructor Create(AEditor : TMemo;ADeletedText : string;
                         APosition : integer);
      procedure DoCommand; override;
      procedure Undo; override;
      procedure Redo; override;
  end;

  TTypingUndoItem = class(TClearingUndoItem)
    private
      CurPos   : integer;
      InsertedText  : string;
    protected
      function GetUndoDescription : string; override;
      function GetShortUndoDescription : string; override;
      function GetRedoDescription : string; override;
      function GetShortRedoDescription : string; override;
      function GetUndoMenuText : string; override;
      function GetRedoMenuText : string; override;
    public
      constructor Create(AEditor : TMemo;AInsertedText,ADeletedText : string;
                         APosition : integer);
      procedure AddText(AText : string2; APos : integer);
      procedure Undo; override;
      procedure Redo; override;
  end;

  TFontChangeUndoItem = class(TUndoItem)
    private
      Font,
      OldFont : TFont;
      Editor : TMemo;
    protected
      function GetUndoDescription : string; override;
      function GetShortUndoDescription : string; override;
      function GetRedoDescription : string; override;
      function GetShortRedoDescription : string; override;
      function GetUndoMenuText : string; override;
      function GetRedoMenuText : string; override;
    public
      constructor Create(AEditor : TMemo;AFont : TFont);
      destructor destroy; override;
      procedure DoCommand; override;
      procedure Undo; override;
      procedure Redo; override;
  end;

  TTextWindow = class(TUndoForm)
    Memo1: TMemo;
    FontDialog1: TFontDialog;
    PopupMenu1: TPopupMenu;
    Cut1: TMenuItem;
    Copy1: TMenuItem;
    Paste1: TMenuItem;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Memo1KeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormCreate(Sender: TObject);
    procedure Memo1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
  private
    { Private declarations }
    Typing            : boolean;
    procedure EndTyping;
  public
    { Public declarations }
    procedure ChangeFont;
  end;

var
  TextWindow : TTextWindow;

implementation

{$R *.DFM}

constructor TClearingUndoItem.Create(AEditor : TMemo;ADeletedText : string;
                   APosition : integer);
begin
  inherited Create;
  StartPos := APosition;
  DeletedText := ADeletedText;
  Editor := AEditor;
end;

procedure TClearingUndoItem.DoCommand;
begin
  ;
end;

procedure TClearingUndoItem.Undo;
var
  TempText : string;
begin
  TempText := Editor.Text;
  Insert(DeletedText,TempText,succ(StartPos));
  Editor.Text := TempText;
  Editor.SelStart := StartPos;
  {$IFDEF Win32}
  Editor.Perform(EM_SCROLLCARET,0,0);
  {$ENDIF}
end;

procedure TClearingUndoItem.Redo;
var
  TempText : string;
begin
  TempText := Editor.Text;
  Delete(TempText,succ(StartPos),length(DeletedText));
  Editor.Text := TempText;
  Editor.SelStart := StartPos;
  {$IFDEF Win32}
  Editor.Perform(EM_SCROLLCARET,0,0);
  {$ENDIF}
end;

function TClearingUndoItem.GetDescr(Msg,AText : string;TextLength : integer):string;
var
  TypedText : string;
begin
  TypedText := Copy(AText,1,TextLength);
  if length(AText) > length(TypedText) then
    TypedText := TypedText + '...';
  Result := Format(Msg,[TypedText]);
end;

function TClearingUndoItem.GetUndoDescription : string;
begin
  Result := GetDescr(sClearUndoDescr,DeletedText,25);
end;

function TClearingUndoItem.GetShortUndoDescription : string;
begin
  Result := GetDescr(sClearShortRedoDescr,DeletedText,10);
end;

function TClearingUndoItem.GetRedoDescription : string;
begin
  Result := GetDescr(sClearRedoDescr,DeletedText,25);
end;

function TClearingUndoItem.GetShortRedoDescription : string;
begin
  Result := GetDescr(sClearShortRedoDescr,DeletedText,10);
end;

function TClearingUndoItem.GetUndoMenuText : string;
begin
  Result := sClearUndoMenu;
end;

function TClearingUndoItem.GetRedoMenuText : string;
begin
  Result := sClearRedoMenu;
end;
{ ------------------------------------------------ }
constructor TTypingUndoItem.Create(AEditor : TMemo;AInsertedText,ADeletedText : string;
                   APosition : integer);
begin
  inherited Create(AEditor,ADeletedText,APosition);
  AddText(AInsertedText,APosition);
end;

procedure TTypingUndoItem.AddText(AText : string2;APos : integer);
const
  BackSpace = #08;
  CR        = #13;
  LF        = #10;
var
  Temp : integer;
begin
  if AText = CR then begin
    AText := AText + LF;
    CurPos := APos + 2;
  end
  else if AText[1] = BackSpace then begin
    if APos > 0 then begin
      if InsertedText = '' then
        Insert(Editor.Text[(APos)],DeletedText,1)
      else
        Delete(InsertedText,length(InsertedText),1);
      CurPos := pred(APos);
    end;
  end
  else begin
    InsertedText := InsertedText + AText;
    CurPos := succ(APos);
  end;
end;

procedure TTypingUndoItem.Undo;
var
  TempText : string;
begin
  TempText := Editor.Text;
  Delete(TempText,succ(StartPos),length(InsertedText));
  if DeletedText <> '' then
    Insert(DeletedText,TempText,succ(StartPos));
  Editor.Text := TempText;
  Editor.SelStart := StartPos;
  {$IFDEF Win32}
  Editor.Perform(EM_SCROLLCARET,0,0);
  {$ENDIF}
end;

procedure TTypingUndoItem.Redo;
var
  TempText : string;
begin
  TempText := Editor.Text;
  if DeletedText <> '' then
    if StartPos > CurPos then
      Delete(TempText,succ(CurPos),length(DeletedText))
    else
      Delete(TempText,succ(StartPos),length(DeletedText));
  Insert(InsertedText,TempText,succ(StartPos));
  Editor.Text := TempText;
  Editor.SelStart := CurPos;
  {$IFDEF Win32}
  Editor.Perform(EM_SCROLLCARET,0,0);
  {$ENDIF}
end;

function TTypingUndoItem.GetUndoDescription : string;
begin
  Result := GetDescr(sTextUndoDescr,InsertedText,25);
end;

function TTypingUndoItem.GetShortUndoDescription : string;
begin
  Result := GetDescr(sTextShortRedoDescr,InsertedText,10);
end;

function TTypingUndoItem.GetRedoDescription : string;
begin
  Result := GetDescr(sTextRedoDescr,InsertedText,25);
end;

function TTypingUndoItem.GetShortRedoDescription : string;
begin
  Result := GetDescr(sTextShortRedoDescr,InsertedText,10);
end;

function TTypingUndoItem.GetUndoMenuText : string;
begin
  Result := sTextUndoMenu;
end;

function TTypingUndoItem.GetRedoMenuText : string;
begin
  Result := sTextRedoMenu;
end;
{ ------------------------------------------------ }
constructor TFontChangeUndoItem.Create(AEditor : TMemo;AFont : TFont);
begin
  inherited Create;
  Editor := AEditor;
  Font := TFont.Create;
  OldFont := TFont.Create;
  Font.Assign(AFont);
end;

destructor TFontChangeUndoItem.destroy;
begin
  Font.Free;
  OldFont.Free;
  inherited destroy;
end;

procedure TFontChangeUndoItem.DoCommand;
begin
  OldFont.Assign(Editor.Font);
  Editor.Font.Assign(Font);
end;

procedure TFontChangeUndoItem.Undo;
begin
  Editor.Font.Assign(OldFont);
end;

procedure TFontChangeUndoItem.Redo;
begin
  Editor.Font.Assign(Font);
end;

function TFontChangeUndoItem.GetUndoDescription : string;
begin
  Result := sFontUndoDescr;
end;

function TFontChangeUndoItem.GetShortUndoDescription : string;
begin
  Result := sFontShortRedoDescr;
end;

function TFontChangeUndoItem.GetRedoDescription : string;
begin
  Result := sFontRedoDescr;
end;

function TFontChangeUndoItem.GetShortRedoDescription : string;
begin
  Result := sFontShortRedoDescr;
end;

function TFontChangeUndoItem.GetUndoMenuText : string;
begin
  Result := sFontUndoMenu;
end;

function TFontChangeUndoItem.GetRedoMenuText : string;
begin
  Result := sFontRedoMenu;
end;
{ ------------------------------------------------ }
procedure TTextWindow.FormCreate(Sender: TObject);
begin
  Typing := false;
end;

procedure TTextWindow.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action := caFree;
end;

procedure TTextWindow.EndTyping;
begin
  if Typing then begin
    Typing := false;
  end;
end;

procedure TTextWindow.Memo1KeyDown(Sender: TObject; var Key: Word;
  Shift: TShiftState);
var
  KeyState : TKeyboardState;
  Buffer : array[0..2] of char;
  ToASCIIResult : integer;
  Item : TUndoItem;
begin
  Item := nil;
  with Memo1 do
    if (SelLength > 0) and (key in [VK_Delete,VK_Back]) then begin
      EndTyping;
      Item := TClearingUndoItem.Create(Memo1,SelText,SelStart);
    end
    else if key = VK_Delete then begin
      Item := TClearingUndoItem.Create(Memo1,Text[succ(SelStart)],SelStart);
    end
    else begin
      FillChar(Buffer,sizeof(Buffer),0);
      GetKeyboardState(KeyState);
      {$IFDEF Win32}
      ToASCIIResult := ToASCII(Key,MapVirtualKey(Key,0),KeyState,Buffer,0);
      {$ELSE}
      ToASCIIResult := ToASCII(Key,MapVirtualKey(Key,0),@KeyState,@Buffer,0);
      {$ENDIF}
      if ToASCIIResult > 0 then begin
        if not Typing then begin
          Item := TTypingUndoItem.Create(Memo1,StrPas(Buffer),SelText,SelStart);
          Typing := true;
        end
        else
          with UndoStack.CurrentItem as TTypingUndoItem do
            AddText(StrPas(Buffer),(SelStart));
      end
      else begin
        EndTyping;
      end;
    end;
  if Item <> nil then
    if UndoStack.Submit(Item) = ssFull then
      ShowMessage(Format(sStackFull,[UndoStack.MaxItems]));
end;

procedure TTextWindow.Memo1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  EndTyping;
end;

procedure TTextWindow.ChangeFont;
var
  Item : TUndoItem;
begin
  EndTyping;
  with FontDialog1 do begin
    Font := Memo1.Font;
    if Execute then begin
      Item := TFontChangeUndoItem.Create(Memo1,Font);
      if UndoStack.Submit(Item) = ssFull then
        ShowMessage(Format(sStackFull,[UndoStack.MaxItems]));
    end;
  end;
end;

end.